home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
MacMETH 3.2.4
/
More Examples
/
Hennessy1.MOD
< prev
next >
Wrap
Text File
|
1996-06-20
|
6KB
|
288 lines
MODULE Hennessy1;
FROM Storage IMPORT ALLOCATE;
FROM SYSTEM IMPORT VAL, TSIZE;
FROM SYSTEM IMPORT REG, SETREG;
FROM InOut IMPORT WriteLn, WriteString, WriteInt, Read, OpenOutput, CloseOutput;
CONST
permbase = 1.75;
queensbase = 1.83;
towersbase = 2.39;
(* Towers *)
maxcells = 18;
stackrange = (*0..*) 3;
(* Intmm, Mm *)
rowsize = 40;
(* Perm *)
permrange = (*0 ..*)10;
TYPE
(* Towers *)
element = RECORD
discsize: LONGINT;
next: LONGINT;
END ;
Proc = PROCEDURE;
VAR
fixed,floated: REAL; ch: CHAR;
(* Perm *)
permarray: ARRAY [0..permrange] OF LONGINT;
pctr: LONGINT;
(* Towers *)
stack: ARRAY [0..stackrange] OF LONGINT;
cellspace: ARRAY [0..maxcells] OF element;
freelist: LONGINT;
movesdone: LONGINT;
(* global procedures *)
PROCEDURE Getclock (): LONGINT;
TYPE P = POINTER TO LONGINT;
VAR ticks: P; tk: LONGINT;
BEGIN ticks := VAL(P, 16AH);
tk := ticks^; RETURN TRUNCD(FLOATD(tk) * (1000.0D0/60.0D0) + 0.5D0)
END Getclock;
(* Permutation program, heavily recursive, written by Denny Brown. *)
PROCEDURE Swap (VAR a,b: LONGINT);
VAR t: LONGINT;
BEGIN t := a; a := b; b := t;
END Swap;
PROCEDURE Initialize ();
VAR i: LONGINT;
BEGIN i := 1D;
WHILE i <= 7D DO
permarray[i] := i-1D;
INC(i)
END
END Initialize;
PROCEDURE Permute (n: LONGINT);
VAR k: LONGINT;
BEGIN
pctr := pctr + 1D;
IF ( n#1D ) THEN
Permute(n-1D);
k := n-1D;
WHILE k >= 1D DO
Swap(permarray[n], permarray[k]);
Permute(n-1D);
Swap(permarray[n], permarray[k]);
DEC(k)
END
END
END Permute;
PROCEDURE Perm ();
VAR i: LONGINT;
BEGIN
pctr := 0; i := 1D;
WHILE i <= 5D DO
Initialize();
Permute(7);
INC(i)
END ;
IF ( pctr # 43300D) THEN WriteString(" Error in Perm.$") END
END Perm;
(* Program to Solve the Towers of Hanoi *)
PROCEDURE Makenull (s: LONGINT);
BEGIN stack[s] := 0
END Makenull;
PROCEDURE Getelement (): LONGINT;
VAR temp: LONGINT;
BEGIN
IF ( freelist>0D) THEN
temp := freelist;
freelist := cellspace[freelist].next;
ELSE
WriteString("out of space $")
END ;
RETURN (temp);
END Getelement;
PROCEDURE Push(i,s: LONGINT);
VAR localel: LONGINT; errorfound: BOOLEAN;
BEGIN
errorfound := FALSE;
IF ( stack[s] > 0D) THEN
IF ( cellspace[stack[s]].discsize<=i ) THEN
errorfound := TRUE;
WriteString("disc size error$")
END
END ;
IF ( ~ errorfound ) THEN
localel := Getelement();
cellspace[localel].next := stack[s];
stack[s] := localel;
cellspace[localel].discsize := i
END
END Push;
PROCEDURE Init (s,n: LONGINT);
VAR discctr: LONGINT;
BEGIN
Makenull(s); discctr := n;
WHILE discctr >= 1D DO
Push(discctr,s);
DEC(discctr)
END
END Init;
PROCEDURE Pop (s: LONGINT): LONGINT;
VAR temp, temp1: LONGINT;
BEGIN
IF ( stack[s] > 0D) THEN
temp1 := cellspace[stack[s]].discsize;
temp := cellspace[stack[s]].next;
cellspace[stack[s]].next := freelist;
freelist := stack[s];
stack[s] := temp;
RETURN (temp1)
ELSE
WriteString("nothing to pop $")
END
END Pop;
PROCEDURE Move (s1,s2: LONGINT);
BEGIN
Push(Pop(s1),s2);
movesdone := movesdone+1D;
END Move;
PROCEDURE tower(i,j,k: LONGINT);
VAR other: LONGINT;
BEGIN
IF ( k=1D) THEN
Move(i,j);
ELSE
other := 6D-i-j;
tower(i,other,k-1D);
Move(i,j);
tower(other,j,k-1D)
END
END tower;
PROCEDURE Towers ();
VAR i: LONGINT;
BEGIN i := 1D;
WHILE i <= LONG(maxcells) DO cellspace[i].next := i-1D; INC(i) END ;
freelist := maxcells;
Init(1,14);
Makenull(2);
Makenull(3);
movesdone := 0;
tower(1,2,14);
IF ( movesdone # 16383D) THEN WriteString(" Error in Towers.$") END
END Towers;
(* The eight queens problem, solved 50 times. *)
PROCEDURE Try(i: LONGINT; VAR q: BOOLEAN; VAR a, b, c: ARRAY OF BOOLEAN; VAR x: ARRAY OF LONGINT);
VAR j: LONGINT;
BEGIN
j := 0;
q := FALSE;
WHILE (~q) & (j # 8D) DO
j := j + 1D;
q := FALSE;
IF b[j] & a[i+j] & c[i-j+7D] THEN
x[i] := j;
b[j] := FALSE;
a[i+j] := FALSE;
c[i-j+7D] := FALSE;
IF i < 8D THEN
Try(i+1D,q,a,b,c,x);
IF ~q THEN
b[j] := TRUE;
a[i+j] := TRUE;
c[i-j+7D] := TRUE
END
ELSE q := TRUE
END
END
END
END Try;
PROCEDURE Doit ();
VAR i: LONGINT; q: BOOLEAN;
a: ARRAY [0..9] OF BOOLEAN;
b: ARRAY [0..17] OF BOOLEAN;
c: ARRAY [0..15] OF BOOLEAN;
x: ARRAY [0..9] OF LONGINT;
BEGIN
i := 0 - 7;
WHILE i <= 16D DO
IF (i >= 1D) & (i <= 8D) THEN a[i] := TRUE END ;
IF i >= 2D THEN b[i] := TRUE END ;
IF i <= 7D THEN c[i+7D] := TRUE END ;
i := i + 1D;
END ;
Try(1, q, b, a, c, x);
IF ( ~ q ) THEN WriteString(" Error in Queens.$") END
END Doit;
PROCEDURE Queens ();
VAR i: LONGINT;
BEGIN i := 1D;
WHILE i <= 50D DO Doit(); INC(i) END
END Queens;
PROCEDURE Time(s: ARRAY OF CHAR; p: Proc; base, fbase: REAL);
VAR timer: LONGINT;
BEGIN
timer := Getclock();
p;
timer := Getclock()-timer;
WriteString(s);
WriteInt(SHORT(timer), 8); WriteLn;
fixed := fixed + FLOAT(timer)*base;
floated := floated + FLOAT(timer)*fbase
END Time;
PROCEDURE main2(i: INTEGER);
BEGIN
fixed := 0.0; floated := 0.0;
Time("Perm ", Perm, permbase, permbase);
Time("Towers ", Towers, towersbase, towersbase);
Time("Queens ", Queens, queensbase, queensbase);
END main2;
PROCEDURE main;
BEGIN
fixed := 0.0; floated := 0.0;
Time("Perm ", Perm, permbase, permbase);
Time("Towers ", Towers, towersbase, towersbase);
Time("Queens ", Queens, queensbase, queensbase);
WriteLn;
main2(19);
END main;
BEGIN
OpenOutput("H1.Mac");
WriteString("Hennessy1 mit MacMETH 3.2 : "); WriteLn;
WriteLn;
main;
CloseOutput;
WriteLn;
WriteString("any key to terminate. "); WriteLn;
Read(ch);
END Hennessy1.